home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1994 August: Tool Chest / Dev.CD Aug 94.toast / Tool Chest / Development Platforms / Macintosh Common Lisp Related / User Contributions / mapforms (code walker).sea / mapforms (code walker) / mapforms-examples.lisp < prev    next >
Encoding:
Text File  |  1992-04-21  |  4.9 KB  |  133 lines  |  [TEXT/CCL2]
  1. ;;; -*- Mode: LISP; Package: Language-Tools; Base: 10; Syntax: Common-Lisp -*-
  2. ;;;>>SHARED-MESSAGE
  3. ;;;>
  4. ;;;>******************************************************************************************
  5. ;;;>    This may only be used as permitted under the license agreement under
  6. ;;;>    which it has been distributed, and in no other way.
  7. ;;;>******************************************************************************************
  8. ;;;>
  9. ;;;>
  10. ;;; Written May 1982 by David A. Moon for use by the Common Lisp community
  11. ;;; Revised April 1983
  12.  
  13. ;;; Examples of the use of MAPFORMS
  14.  
  15. (DEFUN PRINT-SUBFORMS (FORM)
  16.   (MAPFORMS #'(LAMBDA (FORM KIND USAGE IGNORE)
  17.         (UNLESS (MEMQ KIND *MAPFORMS-NON-FORM-KINDS*)
  18.           (FORMAT T "~&~S for ~S" FORM USAGE)))
  19.         FORM))
  20.  
  21. (DEFUN FREE-VARIABLES (FORM)
  22.   (MAPFORMS #'(LAMBDA (FORM KIND IGNORE FREEVARS)
  23.         (AND (MEMQ KIND '(SET SYMEVAL))
  24.              (NOT (MEMQ FORM *MAPFORMS-BOUND-VARIABLES*))
  25.              (NOT (MEMQ FORM FREEVARS))
  26.              (PUSH FORM FREEVARS))
  27.         FREEVARS)
  28.         FORM ':BOUND-VARIABLES NIL))
  29.  
  30. (DEFUN FIND-ALL-CONSTANTS (FORM)
  31.   (MAPFORMS #'(LAMBDA (FORM KIND IGNORE CONSTANTS)
  32.         (IF (EQ KIND 'QUOTE)
  33.             (PUSHNEW FORM CONSTANTS))
  34.         CONSTANTS)
  35.         FORM))
  36.  
  37. ;Returns a list of lists (variable-or-nil collection-type collection-type...)
  38. (DEFUN FIND-ALL-COLLECTIONS (FORM)
  39.   (MAPFORMS #'(LAMBDA (FORM KIND IGNORE COLLECTIONS)
  40.         (AND (NOT (MEMQ KIND *MAPFORMS-NON-FORM-KINDS*))
  41.              (LISTP FORM)
  42.              (EQ (CAR FORM) 'COLLECT)
  43.              (LET ((VARIABLE NIL) (TYPE 'CONS) ELEM)
  44.                (LOOP FOR (KEYWORD ARG) ON (CDDR FORM) BY 'CDDR
  45.                  WHEN (EQ KEYWORD 'INTO) DO (SETQ VARIABLE ARG)
  46.                  WHEN (EQ KEYWORD 'USING) DO (SETQ TYPE ARG))
  47.                (OR (SETQ ELEM (ASSQ VARIABLE COLLECTIONS))
  48.                (PUSH (SETQ ELEM (NCONS VARIABLE)) COLLECTIONS))
  49.                (PUSHNEW TYPE (CDR ELEM))))
  50.         COLLECTIONS)
  51.         FORM))
  52.  
  53. ;Expands all macros in the form, except those that have templates
  54. ;Maybe an option to do them, too??
  55. (DEFUN EXPAND-ALL-MACROS (FORM)
  56.   (COPYFORMS #'(LAMBDA (FORM IGNORE IGNORE) FORM) FORM ':EXPAND-ALL-MACROS T))
  57.  
  58. (DEFUN EXPAND-ALL-MACROS-AND-SUBSTS (FORM)
  59.   (COPYFORMS #'(LAMBDA (FORM KIND IGNORE)
  60.          (VALUES (IF (MEMQ KIND *MAPFORMS-NON-FORM-KINDS*)
  61.                  FORM
  62.                  (MACROEXPAND-1 FORM))
  63.              NIL))
  64.          FORM ':EXPAND-ALL-MACROS T))
  65.  
  66. (DEFVAR *MAPFORMS-IN-FILE-FUNCTION*)
  67. (DEFVAR *MAPFORMS-IN-FILE-STATE*)
  68. (DEFVAR *MAPFORMS-IN-FILE-BOUND-VARIABLES*)
  69. (DEFVAR *MAPFORMS-IN-FILE-USAGE*)
  70.  
  71. ;MAPFORMS over every form in the file
  72. (DEFUN MAPFORMS-IN-FILE (*MAPFORMS-IN-FILE-FUNCTION* FILENAME
  73.              &OPTIONAL &KEY (INITIAL-STATE NIL)
  74.                     (BOUND-VARIABLES 'NO-ENV)
  75.                     (USAGE 'EVAL)
  76.              &AUX (*MAPFORMS-IN-FILE-STATE* INITIAL-STATE)
  77.                   (*MAPFORMS-IN-FILE-BOUND-VARIABLES* BOUND-VARIABLES)
  78.                   (*MAPFORMS-IN-FILE-USAGE* USAGE))
  79.   (WITH-OPEN-FILE (S FILENAME)
  80.     (LET ((GENERIC-PATHNAME (SEND (SEND S ':PATHNAME) ':GENERIC-PATHNAME)))
  81.       (FS:READ-ATTRIBUTE-LIST GENERIC-PATHNAME S)
  82.       (COMPILER:COMPILE-FROM-STREAM S GENERIC-PATHNAME #'MAPFORMS-IN-FILE-1 NIL)
  83.       *MAPFORMS-IN-FILE-STATE*)))
  84.  
  85. (DEFSELECT MAPFORMS-IN-FILE-1 
  86.   ((:DUMP-FORM :DUMP-DEFINITION) (FORM)
  87.    (SETQ *MAPFORMS-IN-FILE-STATE*
  88.      (MAPFORMS *MAPFORMS-IN-FILE-FUNCTION* FORM
  89.            ':INITIAL-STATE *MAPFORMS-IN-FILE-STATE*
  90.            ':BOUND-VARIABLES *MAPFORMS-IN-FILE-BOUND-VARIABLES*
  91.            ':USAGE *MAPFORMS-IN-FILE-USAGE*)))
  92.   ; :DUMP-LAMBDA-EXPRESSION doesn't seem to be used?
  93.   (:EVAL-FORM (FORM) (EVAL FORM))        ;eval-when (compile), hopefully undoable
  94.   (:MACRO-EXPAND (FORM) (MACROEXPAND FORM))
  95.   ((:INITIALIZE :FINALIZE) (&REST IGNORE) NIL)
  96.   (:FOR-FILE () T)
  97.   (:CONS-AREA () DEFAULT-CONS-AREA)
  98.   (:TO-CORE-P () NIL)                ;don't mung the current environment
  99.   (:COMPILER-TYPE () NIL)            ;don't set QC-FILE-IN-PROGRESS
  100.   (:READ (STREAM EOF IGNORE) (READ STREAM NIL EOF))
  101.   )
  102.  
  103. (DEFUN FREE-VARIABLES-IN-FILE (FILENAME)
  104.   (MAPFORMS-IN-FILE #'(LAMBDA (FORM KIND IGNORE FREEVARS)
  105.             (AND (MEMQ KIND '(SET SYMEVAL))
  106.                  (NOT (MEMQ FORM *MAPFORMS-BOUND-VARIABLES*))
  107.                  (NOT (MEMQ FORM FREEVARS))
  108.                  (PUSH FORM FREEVARS))
  109.             FREEVARS)
  110.             FILENAME ':BOUND-VARIABLES NIL))
  111.  
  112. ;This cheats a little and doesn't call the real LOOP parser
  113. ;State is alist of clause name (or LOOP itself) and number of times seen
  114. (DEFUN LOOP-CLAUSES-IN-FILE (FILENAME)
  115.   (LET ((STATS (MAPFORMS-IN-FILE
  116.          #'(LAMBDA (FORM KIND IGNORE STATS)
  117.              (AND (NOT (MEMQ KIND *MAPFORMS-NON-FORM-KINDS*))
  118.               (LISTP FORM)
  119.               (EQ (CAR FORM) 'LOOP)
  120.               (LOOP FOR KWD IN FORM DO
  121.                (IF (OR (EQ KWD 'LOOP) 
  122.                    (SETQ KWD (CAR (SI:LOOP-TASSOC KWD
  123.                                   SI:LOOP-KEYWORD-ALIST))))
  124.                    (LET ((ELEM (ASSOC KWD STATS)))
  125.                  (OR ELEM (PUSH (SETQ ELEM (CONS KWD 0)) STATS))
  126.                  (INCF (CDR ELEM))))))
  127.              STATS)
  128.          FILENAME)))
  129.     (FORMAT T "~&LOOP used ~D time~:P.~%" (OR (CDR (ASSQ 'LOOP STATS)) 0))
  130.     (LOOP FOR (KWD . COUNT) IN (SORT STATS #'STRING-LESSP :KEY #'CAR)
  131.       UNLESS (EQ KWD 'LOOP)
  132.         DO (FORMAT T "  ~A used ~D time~:P.~%" KWD COUNT))))
  133.